home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 2 / Gold Medal Software Volume 2 (Gold Medal) (1994).iso / utils / mclk101.arj / MCLK.PAS < prev    next >
Pascal/Delphi Source File  |  1993-09-10  |  3KB  |  121 lines
  1. program movingclock;
  2. {------------------------------------------------------------------------------
  3.  
  4.                                 REVISION HISTORY
  5.  
  6. v1.00  : 1993/08/19.  First public release.  DDA
  7. v1.00a : 1993/08/30.  Fixed cursoron procedure, with thanks to David Cheung.
  8. v1.01  : 1993/09/10.  New getcursor and setcursor procedures, via Randall
  9.                           Woodman.  Supercede cursoroff/ cursoron.     DDA
  10.  
  11. ------------------------------------------------------------------------------}
  12.  
  13. uses crt ,
  14.      dos ;
  15. const
  16.  progdata = 'MCLK- Free DOS utility: colorful moving clock display.';
  17.  progdat2 = 'V1.01: September 10, 1993. (c) 1993 by David Daniel Anderson - Reign Ware.';
  18.  usage = 'Usage:  MCLK';
  19. var
  20.     rtcol,
  21.     btrow,
  22.     xcord,
  23.     ycord   : byte ;
  24.     dum     : char ;
  25.  
  26. procedure showhelp;
  27. begin
  28.      writeln (progdata);
  29.      writeln (progdat2);
  30.      writeln (usage);
  31.      halt ;
  32. end;
  33.  
  34. { These two cursor procedures are via Randall Woodman }
  35.  
  36. procedure getcursor (var chval, clval : integer );
  37. const
  38.    video  = $0010;
  39.    getcur = $0300;
  40. var
  41.   regs : registers ;
  42. begin
  43.    regs.ax := getcur ;
  44.    intr(video,regs) ;
  45.    chval := regs.ch;  { upper scan line }
  46.    clval := regs.cl;  { lower scan line }
  47. end;
  48.  
  49. procedure setcursor ( startscan, stopscan : integer );
  50. const
  51.   videoio     = $10;
  52.   cursorshape =   1;
  53. var
  54.   regs : registers ;
  55. begin
  56.   with regs do
  57.     begin
  58.       ch:=startscan;
  59.       cl:=stopscan;
  60.       ah:=cursorshape;
  61.       intr(videoio,regs);
  62.     end;
  63. end;
  64.  
  65. function leadingzero(w : word) : string;
  66. var
  67.   s : string;
  68. begin
  69.   str(w:0,s);
  70.   if length(s) = 1 then
  71.     s := '0' + s;
  72.   leadingzero := s;
  73. end;
  74.  
  75. procedure ddate;
  76. var
  77.     h,mi,s,u   : word ;
  78.     date_time  : datetime ;
  79. begin
  80.      gettime (h,mi,s,u);
  81.      with date_time do
  82.      begin
  83.           hour := ( h );
  84.        write ( leadingzero ( hour ) , ':' );
  85.           min  := ( mi );
  86.        write ( leadingzero ( min  ) , ':' );
  87.           sec  := ( s );
  88.        write ( leadingzero ( sec  ));
  89.      end;
  90. end;
  91.  
  92. var ctop, cbot : integer ;
  93.  
  94. begin
  95.     if paramcount <> 0 then showhelp;
  96.  
  97.     rtcol := lo ( windmax ) - 7 ;
  98.     btrow := hi ( windmax ) + 1 ;
  99.     textattr := 8;
  100.     clrscr ;
  101.     randomize ;
  102.     getcursor ( ctop, cbot );
  103.     setcursor ( 0, 0 );
  104.  
  105.     while not keypressed do begin
  106.     textattr := succ ( textattr );
  107.     if ( textattr = 16 ) then
  108.          textattr := 9;
  109.     xcord := 1 + random ( rtcol ) ;
  110.     ycord := 1 + random ( btrow ) ;
  111.     gotoxy ( xcord , ycord );
  112.     ddate ;
  113.     delay ( 990 ) ;
  114.     clrscr ;
  115.     end;
  116.  
  117.     while keypressed do dum := readkey ;
  118.  
  119.     setcursor ( ctop, cbot );
  120. end.
  121.